-- CIS 552, Mini-project
-- by Mike Gottlieb and Reilly Grant

-- |Encapsulates poker rules and reactions to player actions.
module Poker(HandRank, rankHand, -- used to score a game
             GamePhase(..), Action(..), GameState, -- used to play
             players, phase,  -- exported functions of GameState record
             -- for use in Main.hs
             getCurrentPlayer, recentHistory, completePot, deal, ante,
             possibleActions, activePlayers, leavingDraw, newGame,
             pickWinner, reset, validateAction, performAction,
             test) where

import qualified Card
import qualified Deck
import qualified Player
import Test.HUnit hiding (test)
import List
import Util

----------------------- HandRank code -----------------------------------------
-- |The HandRank data represents all of the possible hands of Poker
--  We constructured each hand by grouping matched rank cards (pair, 
--  triple, quad) into one Card.Rank value and then all of the 
--  remaining cards into a list. When a HandRank is constructed 
--  properly it is possible to do a correct comparison between hands
--  using the derived Ord and Eq definitions because Card.Rank is an
--  Int and therefore has Ord and Eq instance definitions
data HandRank = HighCard [Card.Rank] -- Full hand
              | Pair Card.Rank [Card.Rank] -- Pair + 3
              | TwoPair Card.Rank Card.Rank Card.Rank -- Two pair + 1
              | ThreeOf Card.Rank [Card.Rank] -- Three + 2
              | Straight Card.Rank -- High card
              | Flush [Card.Rank] -- Full hand
              | FullHouse Card.Rank Card.Rank -- Triple Double
              | FourOf Card.Rank Card.Rank -- Four + 1
              | StraightFlush Card.Rank
                deriving (Ord, Eq)

-- Provides poker style string explanations of HandRanks
instance Show HandRank where
    show (HighCard rs) = (Card.rankName $ head rs) ++ " high"
    show (Pair r rs) = "pair of " ++ (Card.rankName r) ++ "s"
    show (TwoPair r1 r2 rs) = "pairs of " ++ (Card.rankName r1) ++ "s and " 
                              ++ (Card.rankName r2) ++ "s"
    show (ThreeOf r rs) = "three " ++ (Card.rankName r) ++ "s"
    show (Straight r) = (Card.rankName r) ++ " high straight"
    show (Flush rs) = (Card.rankName $ head rs) ++ " high flush"
    show (FourOf r rs) = "four " ++ (Card.rankName r) ++ "s"
    show (StraightFlush r) = if r == 14 then "royal flush"
                             else (Card.rankName r) ++ " high straight flush"

-- |This function will takes a list of Cards and constructs the appropriate
--  HandRanks such that they can be accurately compared and tie-broken.
--  This means that each element of the hand is put in by its poker rank
--  (triples before pairs, pairs before single cards, and everything in
--  high-to-low rank order)
rankHand :: [Card.T] -> HandRank
rankHand hand = let sorted = map Card.rank (sort hand)
                    isFlush = checkFlush hand
                    isStraight = checkStraight sorted in
                if isStraight && isFlush
                   then StraightFlush $ last sorted
                else if isStraight
                   then Straight $ last sorted
                else if isFlush
                   then Flush $ reverse sorted
                else rankDups hand

-- |Detects a straight in a list of sorted ranks by checking the ranks are 
--  increasing by one.
checkStraight :: [Card.Rank] -> Bool
checkStraight cs = increasingByOne cs

-- |Detects a flush in a hand by checking the last four cards have the same
--  suit as the first.
checkFlush :: [Card.T] -> Bool
checkFlush (c:cs) = countWith ((Card.suit c ==) . Card.suit) cs == 4

-- |Detects all the hands which consist of sets of cards with the same rank.
rankDups :: [Card.T] -> HandRank
rankDups hand = 
    let ranks = map Card.rank hand 
        dups = countDups ranks
        ordering (_,a) (_,b) = compare b a
        sorted = sortBy ordering dups in -- order by how many duplicates
    case sorted of -- so that this pattern match is exhaustive
      [(a,1),(b,1),(c,1),(d,1),(e,1)] -> HighCard $ reverse $ sort ranks
      [(a,2),(b,1),(c,1),(d,1)] -> Pair a $ reverse $ sort [b,c,d]
      [(a,2),(b,2),(c,1)] -> TwoPair (max a b) (min a b) c
      [(a,3),(b,1),(c,1)] -> ThreeOf a $ reverse $ sort [b,c]
      [(a,3),(b,2)] -> FullHouse a b
      [(a,4),(b,1)] -> FourOf a b
      _ -> error $ "Invalid hand: " ++ (show hand)

-- |Makes a hand (list of Cards) from a string description
mkHand :: String -> [Card.T]
mkHand = map ((\(Just x) -> x) . Card.parse) . words

-- |HUnit test for proper hand ranking
testRank h1 h2 = TestCase (assertBool (h1 ++ " < " ++ h2)
                           ((rankHand $ mkHand h1) < (rankHand $ mkHand h2)))

rankTests = TestList [(testRank "2H 3H 4H 5S 7C" "2H 2S 3H 4H 5H"),
                      (testRank "2H 4S 6C 7D 9D" "AH 3H 5H 7C 8H"),
                      (testRank "4H 4S 4C 4D 2S" "10H JH QH KH AH")] 
--------------------- End of HandRanks ----------------------------------------

--------------------- Phases and Actions --------------------------------------
-- |Action represent the individual operations that a Player can do
--  Determining which actions are valid is dependent on the current
--  GamePhase.
data Action = Bet Int
            | Raise Int
            | See
            | Call
            | Fold
            | Check
            | Discard [Card.T]
            | Help
            | Exit
              
-- Pretty prints for actions (discard masks the actual discarded
-- cards so other players cannot see)
instance Show Action where
    show (Bet n)      = "bets " ++ (show n) ++ "."
    show (Raise n)    = "raises " ++ (show n) ++ "."
    show See          = "sees."
    show Call         = "calls."
    show Fold         = "folds."
    show Check        = "checks."
    show (Discard cs) = "discards " ++ (show $ length cs) ++ "."
    show _            = ""

-- |GamePhase represents the current phase of a round of Poker. Each
--  Bet1 and Bet2 are phases that are entered in case actual betting
--  occurs. They represent the process from a bet to a call (includes
--  possible raising)
data GamePhase = Ante
               | Bet1
               | Draw
               | PostDraw
               | Bet2
               | Final
                 deriving (Show, Enum, Eq)

-- |Links a game phase to the valid actions in that phase.
possibleActions :: GamePhase -> [String]
possibleActions Ante     = ["bet", "check"]
possibleActions Bet1     = ["see", "raise", "call", "fold"]
possibleActions Draw     = ["discard", "check"]
possibleActions PostDraw = ["bet", "check"]
possibleActions Bet2     = ["see", "raise", "call", "fold"]
possibleActions Final    = ["deal"]

-- |Check that in the current game phase the given action is valid.
validatePhaseToAction :: GamePhase -> Action -> Bool
validatePhaseToAction Ante (Bet _)     = True
validatePhaseToAction Ante Check       = True
validatePhaseToAction Bet1 See         = True
validatePhaseToAction Bet1 (Raise _)   = True
validatePhaseToAction Bet1 Call        = True
validatePhaseToAction Bet1 Fold        = True
validatePhaseToAction Draw (Discard _) = True
validatePhaseToAction Draw Check       = True
validatePhaseToAction PostDraw (Bet _) = True
validatePhaseToAction PostDraw Check   = True
validatePhaseToAction Bet2 See         = True
validatePhaseToAction Bet2 (Raise _)   = True
validatePhaseToAction Bet2 Call        = True
validatePhaseToAction Bet2 Fold        = True
validatePhaseToAction _ _              = False

testPhase gp a = 
    TestCase  (assertBool 
                ("player " ++ (show a) ++ " in phase " ++ (show gp) ++ "\n")
                              (validatePhaseToAction gp a))

-- These examples test validatePhaseToAction. 
phaseTests = TestList [(testPhase Ante (Bet 10)),
                       (testPhase Bet1 (Fold))]

--------------------- End of Phases and Actions -------------------------------

------------- All code ahead deals with the GameState data type ---------------

-- |A GameState represents all the information necessary to describe
--  a current round of Poker at a given time.
data GameState = Poker { players::[Player.T],
                         dealer::Int, -- dealer for the round
                         currentPlayer::Int, -- indexes into players and pot
                         pot::[Int], -- tracked for each player
                         deck::Deck.T,
                         phase::GamePhase,
                         lastBetter::Int, -- last person to increase lastBet
                         amountToPlay::Int, -- initialize to ante amount
                         history::[String] } -- recent actions for display
               deriving (Show)

-- |Construct a new game state from a list of players.
newGame :: [Player.T] -> IO GameState
newGame ps = do theDeck <- Deck.shuffle Deck.deck
                return Poker { players = ps,
                               dealer = 0,
                               currentPlayer = 1,
                               pot = [],
                               deck = theDeck,
                               phase = Ante,
                               lastBetter = -1,
                               amountToPlay = 0,
                               history = [] }
             
-- |Deal 5 cards to each player in the game. The resulting deck
--  is returned from each deal so its state holds.
deal :: GameState -> GameState
deal s = s { players = players',
             deck = deck',
             history = "Cards dealt." : (history s) }
         where (players', deck') = deal' (players s) (deck s)
               deal' [] d = ([], d)
               deal' (p:ps) d = let (p', d') = Player.draws p d 5
                                    (rest, d'') = deal' ps d'
                                in (p' : rest, d'')
             
-- |The amount players ante.
defaultAnte = 10

-- |Ante up! Tests if players have less than the ante amount
--  and disables them if so.
ante :: GameState -> GameState
ante s = s { players = map ante' (players s),
             pot = take (length $ players s) (repeat defaultAnte),
             amountToPlay = defaultAnte,
             lastBetter = currentPlayer s,
             phase = Ante,
             history = ["All players ante " ++ (show defaultAnte) ++ "."]}
         where ante' p = 
                   if (Player.money p) < defaultAnte
                   then p { Player.inPlay = False }
                   else p { Player.money = (Player.money p) - defaultAnte }

-- |Changes the state to after the drawing round, play resumes with the next
--  active player after the dealer.
leavingDraw :: GameState -> GameState
leavingDraw s = let nextPlayer = findNextPlayer s (dealer s) 1 in
                s { phase = PostDraw,
                    currentPlayer = nextPlayer,
                    lastBetter = nextPlayer }

-- |Reset all players.
reset :: GameState -> GameState
reset s = let p' = map Player.reset (players s) in
          s { players = p' }

-- |Get the player data for the current player.
getCurrentPlayer :: GameState -> Player.T
getCurrentPlayer s = players s !! (currentPlayer s)

-- |Get the portion of the pot for the current player.
getCurrentPlayerPot :: GameState -> Int
getCurrentPlayerPot s = pot s !! (currentPlayer s)

-- |Get a "paragraph" describing the actions that have most recently occured.
recentHistory :: GameState -> String
recentHistory s = unwords $ reverse $ take (length (players s)) (history s)

-- |Calculate the complete total in the pot by summing each player's pot.
completePot :: GameState -> Int
completePot s = sum $ pot s

-- |Determines if a particular Action is valid given the GameState.
--  Returns Nothing if the action is valid, otherwise a string with the
--  appropriate error.
validateAction :: Action -> GameState -> Maybe String
validateAction Exit _ = Nothing
validateAction Help _ = Nothing
validateAction a s = 
    if validatePhaseToAction (phase s) a then
        case a of
          (Bet n)      -> if validateSpend s n then 
                              if validateRaise s n then Nothing
                              else Just "Other players cannot match the bet.\n"
                          else Just "You don't have enough money.\n"
          (Raise n)    -> if validateSpend s (n + (amountToPlay s)) then
                              if validateRaise s n then Nothing
                              else Just "Other players cannot match raise.\n"
                          else Just "You don't have enough money.\n"
          See          -> if not (validateCall s) then Nothing
                          else Just "You are in position to call.\n"
          Call         -> if validateCall s then Nothing
                          else Just "You are not in position to call.\n"
          (Discard cs) -> if validateDiscard s cs then Nothing
                          else Just "You don't have all of those cards.\n"
          _            -> Nothing
    else Just "You cannot perform that action at this time.\n"



-- |Checks that the player attempting to call is in position to do so.
validateCall :: GameState -> Bool
validateCall s = let p = currentPlayer s
                     b = lastBetter s
                     n = length (players s) in
                 findNextPlayer s p 1 == b

-- |Checks that the current player has all of the cards they are trying to
--  discard.
validateDiscard :: GameState -> [Card.T] -> Bool
validateDiscard s cs = let p = getCurrentPlayer s
                           h = Player.hand p in
                       and $ map (flip elem h) cs
                       
-- |Checks that the current player has at least the amount he is attempting
--  to bet or raise. 
validateSpend :: GameState -> Int -> Bool
validateSpend s n = let p = getCurrentPlayer s in
                    Player.money p >= n

-- |Checks that all players can afford the amount that the current player
--  is attempting to bet or raise. (prevents side pots)
validateRaise :: GameState -> Int -> Bool
validateRaise s n = let ps = filter (Player.inPlay) (players s) in
                    and $ map ((n <=) . Player.money) ps

-- |Perform the current player's action, affecting a change in the current
--  game state. This function actually performs the action and then tests
--  the resulting state for certain special cases like all players but 1
--  folding or folds that proceed to the next round.
performAction :: Action -> GameState -> GameState
performAction a s = 
    let cp = currentPlayer s -- index of current player
        ps = players s
        p = getCurrentPlayer s -- current player data
        pp = getCurrentPlayerPot s
        nextPlayerGuess = findNextPlayer s cp 1 
        newState = -- result of performing the action
            case a of 
              (Bet n)      -> let p' = Player.bets p n in
                              s { pot = replace cp (amountToPlay s + n) (pot s),
                                  players = replace cp p' ps,
                                  lastBetter = cp,
                                  amountToPlay = amountToPlay s + n,
                                  -- bet moves to next phase
                                  phase = succ (phase s) } 
              (Raise n)    -> let p' = Player.bets p (amountToPlay s + n - pp) 
                              in 
                              s { pot = replace cp (amountToPlay s+n) (pot s),
                                  players = replace cp p' ps,
                                  lastBetter = cp,
                                  amountToPlay = amountToPlay s + n }
              See          -> let p' = Player.bets p (amountToPlay s - pp) in
                              s { pot = replace cp (amountToPlay s) (pot s),
                                  players = replace cp p' ps }
              Call         -> let p' = Player.bets p (amountToPlay s - pp) in
                              s { pot = replace cp (amountToPlay s) (pot s),
                                  players = replace cp p' ps,
                                  -- call moves to next phase
                                  phase = succ (phase s) } 
              Fold         -> let p' = Player.folds p in
                              s { players = replace cp p' ps,
                                  phase = if (lastBetter s) == nextPlayerGuess
                                          -- leaves the betting phase
                                          then succ (phase s)
                                          else (phase s) }
              Check        -> s { phase = if (lastBetter s) == nextPlayerGuess
                                          -- skips the betting phases
                                          then succ $ succ (phase s)
                                          else (phase s) }
              (Discard cs) -> let p' = Player.discards p cs
                                  n = length cs
                                  (p'',d) = Player.draws p' (deck s) n in
                              s { players = replace cp p'' ps,
                                  deck = d }
              Help         -> error "Help action should never be performed."
              Exit         -> error "Exit action should never be performed."
        -- updates the history with the new action      
        newHistory = (Player.name p ++ " " ++ (show a)) : (history s)
        -- gets the nextplayer given the new state in case of folds
        nextPlayer = findNextPlayer newState cp 1
    in newState { history = newHistory,
                  currentPlayer = nextPlayer,
                  phase = if (activePlayers newState) == 1 then Final 
                          else (phase newState) } -- out of players

-- |Cycles through the players looking for one that's still in play, gives
--  up if the current player is the only one left.
findNextPlayer :: GameState -> Int -> Int -> Int
findNextPlayer s start delta = 
    let next = (start + delta) `mod` (length $ players s) in
    if next == start then next
    else if not (Player.inPlay (players s !! next)) 
         then findNextPlayer s start (delta + 1)
    else next

-- |Current number of active players.
activePlayers :: GameState -> Int
activePlayers s = countWith Player.inPlay (players s)

-- |Picks the winning hand(s) and distributes the reward(s).
pickWinner :: GameState -> GameState
pickWinner s = 
    -- get the ranks of the hands still in play
    let ranks = map (rankHand . Player.hand) (filter Player.inPlay (players s))
        sorted = reverse $ sort ranks
        ps = map (\x -> if (rankHand . Player.hand) x /= (head sorted) then
                            x { Player.inPlay = False }
                        else x ) (players s)
        winners = countWith Player.inPlay ps
        reward = completePot s `div` winners -- split the pot
        ps' = map (\x -> if Player.inPlay x 
                         then x { Player.money = Player.money x + reward }
                         else x) ps
    in s { players = ps' }

-- |Tests that the result of validateAction is correct.
validated :: Maybe String -> Bool
validated Nothing = True
validated (Just _) = False

-- Test Data
theDeck0 = Deck.deck

(player1, theDeck1) = Player.draws (Player.player "Reilly") theDeck0 5
(player2, theDeck2) = Player.draws (Player.player "Mike") theDeck1 5
(player3, theDeck)  = Player.draws (Player.player "Carl") theDeck2 5

testGameState :: GameState
testGameState = Poker { players = [player1, player2, player3], 
                        dealer = 0,
                        currentPlayer = 1, -- player after dealer
                        pot = [10, 10, 10],
                        deck = theDeck,
                        phase = Ante,
                        lastBetter = 0,
                        amountToPlay = 10,
                        history = [] }

testEndGameState = testGameState { phase = Final }

-- HUnit tests for problematic Game situations

testGame1 = let s1 = performAction (Bet 10) (testGameState)
                s2 = performAction (Fold) s1
                s3 = performAction (Raise 10) s2 in
            performAction (Call) s3
                      
caseGame1 = TestCase $ assertBool "Test of call position adjustment\n"
            ( (phase testGame1 == Draw) &&
              ((Player.inPlay $ players testGame1 !! 2) == False) )

testGame2 = let s1 = performAction (Fold) (testGameState)
                s2 = performAction (Fold) s1 in
            performAction (Call) s2

caseGame2 = TestCase $ assertBool "Test of all folding\n"
            ( (phase testGame2 == Final) &&
              ((Player.inPlay $ players testGame2 !! 2) == False) &&
              ((Player.inPlay $ players testGame2 !! 1) == False)  )
            
testGame3 = let s1 = performAction (Bet 10) (testGameState)
                s2 = performAction (Fold) s1
                s3 = performAction (Raise 10) s2 in
            performAction (Fold) s3
            
caseGame3 = TestCase $ assertBool "Test bet, fold, raise, fold\n"
            ( (phase testGame3 == Final) &&
              ((Player.inPlay $ players testGame3 !! 2) == False) &&
              ((Player.inPlay $ players testGame3 !! 1) == False)  )

testGame4 = let s1 = performAction (Bet 10) (testGameState)
                s2 = performAction (Fold) s1
                s3 = performAction (Raise 10) s2 in
            performAction (Call) s3
                            
caseGame4 = TestCase $ assertBool ("Test of proper pot size = " ++ 
                                   show(completePot testGame4) ++ "\n") 
            ( (phase testGame4 == Draw) &&
            ((Player.inPlay $ players testGame4 !! 2) == False) &&
             (completePot testGame4 == 70) )

caseEndGame = let endGame = pickWinner testEndGameState in
              TestCase $ assertBool "Test of winner and pot distribution."
              ([False, True, False] == map Player.inPlay (players endGame) &&
               [1024, 1054, 1024] == map Player.money (players endGame))
              
gameTests = TestList [ caseGame1,
                       caseGame2,
                       caseGame3,
                       caseGame4,
                       caseEndGame ] 

-- |Run all poker tests.
test = runTestTT $ TestList [rankTests, phaseTests, gameTests]
